home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / utils / floating-toolbar.el.z / floating-toolbar.el
Encoding:
Text File  |  1998-05-21  |  14.0 KB  |  387 lines
  1. ;;; floating-toolbar.el -- popup toolbar support for XEmacs.
  2. ;; Copyright (C) 1997 Kyle E. Jones
  3.  
  4. ;; Author: Kyle Jones <kyle_jones@wonderworks.com>
  5. ;; Keywords: lisp
  6.  
  7. ;; This file is part of XEmacs.
  8.  
  9. ;; XEmacs is free software; you can redistribute it and/or modify
  10. ;; it under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 1, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; XEmacs is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17. ;; GNU General Public License for more details.
  18.  
  19. ;; A copy of the GNU General Public License can be obtained from this
  20. ;; program's author (send electronic mail to kyle@uunet.uu.net) or from
  21. ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22. ;; Boston, MA 02111-1307, USA.
  23.  
  24. ;;; Commentary:
  25.  
  26. ;; Popup toolbar for XEmacs (probably require XEmacs 19.14 or later)
  27. ;; Send bug reports to kyle_jones@wonderworks.com
  28.  
  29. ;; The command `floating-toolbar' pops up a small frame
  30. ;; containing a toolbar.  The command should be bound to a
  31. ;; button-press event.  If the mouse press happens over an
  32. ;; extent that has a non-nil 'floating-toolbar property, the
  33. ;; value of that property is the toolbar instantiator that will
  34. ;; be displayed.  Otherwise the toolbar displayed is taken from
  35. ;; the variable `floating-toolbar'.  This variable can be made
  36. ;; buffer local to produce buffer local floating toolbars.
  37. ;;
  38. ;; `floating-toolbar-or-popup-mode-menu' works like `floating-toolbar'
  39. ;; except that if no toolbar is found, `popup-mode-menu' is called.
  40. ;;
  41. ;; `floating-toolbar-from-extent-or-popup-mode-menu' works like
  42. ;; `floating-toolbar-or-popup-mode-menu' except only extent local
  43. ;; toolbars are used; the value of floating-toolbar is not used.
  44. ;;
  45. ;; Installation:
  46. ;;
  47. ;; Byte-compile the file floating-toolbar.el (with M-x byte-compile-file)
  48. ;; and put the .elc file in a directory in your load-path.  Add the
  49. ;; following line to your .emacs:
  50. ;;
  51. ;; (require 'floating-toolbar)
  52. ;;
  53. ;; You will also need to bind a mouse click to `floating-toolbar' or to
  54. ;; `floating-toolbar-or-popup-mode-menu'.
  55. ;; 
  56. ;; For 19.12 users:
  57. ;;    If you are using fvwm, [tv]twm or ol[v]wm, you can also add
  58. ;;    the following lines to various configuration file to use
  59. ;;    minimal decorations on the toolbar frame.
  60. ;;
  61. ;;    In .emacs:
  62. ;;       (setq floating-toolbar-frame-name "floating-toolbar")
  63. ;;
  64. ;;    For ol[v]wm use this in .Xdefaults:
  65. ;;       olvwm.NoDecor: floating-toolbar
  66. ;;         or
  67. ;;       olwm.MinimalDecor: floating-toolbar
  68. ;;
  69. ;;    For fvvm use this in your .fvwmrc:
  70. ;;       NoTitle floating-toolbar
  71. ;;    or
  72. ;;       Style "floating-toolbar" NoTitle, NoHandles, BorderWidth 0
  73. ;;
  74. ;;    For twm use this in your .twmrc:
  75. ;;       NoTitle { "floating-toolbar" }
  76. ;; 
  77. ;; Under 19.13 and later versions the floating-toolbar frame uses a
  78. ;; transient window that is not normally decorated by window
  79. ;; managers.  So the window manager directives should not be
  80. ;; needed for XEmacs 19.13 and beyond.
  81.  
  82. ;;; Code:
  83.  
  84. (provide 'floating-toolbar)
  85.  
  86. ;; (require 'toolbar)
  87. (require 'x)
  88.  
  89. (defvar floating-toolbar-version "1.02"
  90.   "Version string for the floating-toolbar package.")
  91.  
  92. (defvar floating-toolbar-use-sound nil
  93.   "*Non-nil value means play a sound to herald the appearance
  94. and disappearance of the floating toolbar.
  95.  
  96. `floating-toolbar-appears' will be played when the toolbar appears.
  97. `floating-toolbar-disappears' will be played when the toolbar disappears.
  98.  
  99. See the documentation for the function `load-sound-file' to see how
  100. define sounds.")
  101.  
  102. (defvar floating-toolbar nil
  103.   "*Toolbar instantiator used if mouse event is not over an extent
  104. with a non-nil 'floating-toolbar property.  This variable can be
  105. made local to a buffer to have buffer local floating toolbars.")
  106.  
  107. (defvar floating-toolbar-help-font nil
  108.   "*Non-nil value should be a font to be used to display toolbar help
  109. messages.  The floating toolbar frame will have a minibuffer window
  110. so that it can display any help text that is attached to the toolbar
  111. buttons.")
  112.  
  113. (defvar floating-toolbar-frame-name nil
  114.   "*The frame name for the frame used to display the floating toolbar.")
  115.  
  116. ;;;
  117. ;;; End of user variables.
  118. ;;;
  119.  
  120. (defvar floating-toolbar-frame nil
  121.   "The floating toolbar is displayed in this frame.")
  122.  
  123. (defvar floating-toolbar-display-pending nil
  124.   "Non-nil value means the toolbar frame will be visible as soon
  125. as the X server gets around to displaying it.  Nil means it
  126. will be invisible as soon as the X server decides to hide it.")
  127.  
  128. (defun floating-toolbar-displayed ()
  129.   (and (frame-live-p floating-toolbar-frame)
  130.        (frame-visible-p floating-toolbar-frame)))
  131.  
  132. ;;;###autoload
  133. (defun floating-toolbar (event &optional extent-local-only)
  134.   "Popup a toolbar near the current mouse position.
  135. The toolbar instantiator used is taken from the 'floating-toolbar
  136. property of any extent under the mouse.  If no such non-nil
  137. property exists for any extent under the mouse, then the value of the
  138. variable `floating-toolbar' is checked.  If its value si nil, then
  139. no toolbar will be displayed.
  140.  
  141. This command should be bound to a button press event.
  142.  
  143. When called from a program, first arg EVENT should be the button
  144. press event.  Optional second arg EXTENT-LOCAL-ONLY specifies
  145. that only extent local toolbars should be used; this means the
  146. `floating-toolbar' variable will not be consulted."
  147.   (interactive "_e")
  148.   (unless (featurep 'toolbar)
  149.     (error "Floating toolbar requires built in toolbar support."))
  150.   (if (not (mouse-event-p event))
  151.       nil
  152.     (let* ((buffer (event-buffer event))
  153.        (window (event-window event))
  154.        (frame (event-frame event))
  155.        (point (and buffer (event-point event)))
  156.        (glyph-extent (event-glyph-extent event))
  157.        (glyph-extent (if (and glyph-extent
  158.                   (extent-property glyph-extent
  159.                            'floating-toolbar))
  160.                  glyph-extent))
  161.        (extent (or glyph-extent
  162.                (and point
  163.                 (extent-at point buffer 'floating-toolbar))))
  164.        (toolbar (or (and extent (get extent 'floating-toolbar))
  165.             (and (not extent-local-only)
  166.                  (symbol-value-in-buffer 'floating-toolbar
  167.                              buffer nil))))
  168.        (x nil)
  169.        (y nil)
  170.        (echo-keystrokes 0)
  171.        (awaiting-release t)
  172.        (done nil))
  173.       (if (not (consp toolbar))
  174.       nil
  175.     ;; event-[xy]-pixel are relative to the top left corner
  176.     ;; of the frame.  The presence of top and left toolbar
  177.     ;; and the menubar can move this position down and
  178.     ;; leftward, but XEmacs doesn't compensate for this in
  179.     ;; the values returned.  So we do it here, as best we
  180.     ;; can.
  181.     (let* ((params (frame-parameters frame))
  182.            (top (cdr (assq 'top params)))
  183.            (left (cdr (assq 'left params)))
  184.            (xtop-toolbar-height
  185.         (if (specifier-instance top-toolbar)
  186.             (specifier-instance top-toolbar-height)
  187.           0))
  188.            (xleft-toolbar-width
  189.         (if (specifier-instance left-toolbar)
  190.             (specifier-instance left-toolbar-width)
  191.           0))
  192.            ;; better than nothing
  193.            (menubar-height (if (and (featurep 'menubar)
  194.                     current-menubar) 22 0)))
  195.       (setq x (+ left xleft-toolbar-width (event-x-pixel event))
  196.         y (+ top xtop-toolbar-height menubar-height
  197.              (event-y-pixel event))))
  198.     ;; for toolbar spec buffer local variable values
  199.     (and buffer (set-buffer buffer))
  200.     (floating-toolbar-display-toolbar toolbar x y)
  201.     (while (not done)
  202.       (setq event (next-command-event))
  203.       (cond ((and awaiting-release (button-release-event-p event))
  204.          (setq awaiting-release nil))
  205.         ((and (button-release-event-p event)
  206.               (event-over-toolbar-p event)
  207.               (eq floating-toolbar-frame (event-frame event)))
  208.          (floating-toolbar-undisplay-toolbar)
  209.          (and window (select-frame (window-frame window)))
  210.          (and window (select-window window))
  211.          (dispatch-event event)
  212.          (setq done t))
  213.         ((and (button-press-event-p event)
  214.               (event-over-toolbar-p event)
  215.               (eq floating-toolbar-frame (event-frame event)))
  216.          (setq awaiting-release nil)
  217.          (dispatch-event event))
  218.         (t
  219.          ;; push back the event if it was in another frame.
  220.          ;; eat it if it was in the toolbar frame.
  221.          (if (and (event-frame event)
  222.               (not (eq floating-toolbar-frame
  223.                    (event-frame event))))
  224.              (setq unread-command-events
  225.                (cons event unread-command-events)))
  226.          (floating-toolbar-undisplay-toolbar)
  227.          (setq done t))))
  228.     t ))))
  229.  
  230. ;;;###autoload
  231. (defun floating-toolbar-or-popup-mode-menu (event)
  232.   "Like floating-toolbar, but if no toolbar is displayed
  233. run popup-mode-menu."
  234.   (interactive "_e")
  235.   (or (floating-toolbar event) (popup-mode-menu)))
  236.  
  237. ;;;###autoload
  238. (defun floating-toolbar-from-extent-or-popup-mode-menu (event)
  239.   "Like floating-toolbar-or-popup-mode-menu, but search only for an
  240. extent local toolbar."
  241.   (interactive "_e")
  242.   (or (floating-toolbar event t) (popup-mode-menu)))
  243.  
  244. (defun floating-toolbar-display-toolbar (toolbar x y)
  245.   (if (not (frame-live-p floating-toolbar-frame))
  246.       (setq floating-toolbar-frame (floating-toolbar-make-toolbar-frame x y)))
  247.   (set-specifier top-toolbar
  248.          (cons (window-buffer
  249.             (frame-selected-window floating-toolbar-frame))
  250.             toolbar))
  251.   (floating-toolbar-resize-toolbar-frame toolbar)
  252.   ;; fiddle with the x value to try to center the toolbar relative to
  253.   ;; the mouse position.
  254.   (setq x (max 0 (- x (/ (frame-pixel-width floating-toolbar-frame) 2))))
  255.   (floating-toolbar-set-toolbar-frame-position x y)
  256.   (floating-toolbar-expose-toolbar-frame))
  257.  
  258. (defun floating-toolbar-undisplay-toolbar ()
  259.   (floating-toolbar-hide-toolbar-frame))
  260.  
  261. (defun floating-toolbar-hide-toolbar-frame ()
  262.   (if (floating-toolbar-displayed)
  263.       (progn
  264.     (make-frame-invisible floating-toolbar-frame)
  265.     (if (and floating-toolbar-use-sound floating-toolbar-display-pending)
  266.         (play-sound 'floating-toolbar-disappears))
  267.     (setq floating-toolbar-display-pending nil))))
  268.  
  269. (defun floating-toolbar-expose-toolbar-frame ()
  270.   (if (not (floating-toolbar-displayed))
  271.       (progn
  272.     (make-frame-visible floating-toolbar-frame)
  273.     (if (and floating-toolbar-use-sound
  274.          (null floating-toolbar-display-pending))
  275.         (play-sound 'floating-toolbar-appears))
  276.     (setq floating-toolbar-display-pending t))))
  277.  
  278. (defun floating-toolbar-resize-toolbar-frame (toolbar)
  279.   (let ((width 0)
  280.     (height nil)
  281.     (bevel (* 2 (or (cdr (assq 'toolbar-shadow-thickness (frame-parameters)))
  282.             0)))
  283.     (captioned (specifier-instance toolbar-buttons-captioned-p))
  284.     button glyph glyph-list)
  285.     (while toolbar
  286.       (setq button (car toolbar))
  287.       (cond ((null button)
  288.          (setq width (+ width 8)))
  289.         ((eq (elt button 0) ':size)
  290.          (setq width (+ width (elt button 1))))
  291.         ((and (eq (elt button 0) ':style)
  292.           (= (length button) 4)
  293.           (eq (elt button 2) ':size))
  294.          (setq width (+ width bevel (elt button 3))))
  295.         (t
  296.           (setq glyph-list (elt button 0))
  297.           (if (symbolp glyph-list)
  298.           (setq glyph-list (symbol-value glyph-list)))
  299.           (if (and captioned (> (length glyph-list) 3))
  300.           (setq glyph (or (nth 3 glyph-list)
  301.                   (nth 4 glyph-list)
  302.                   (nth 5 glyph-list)))
  303.         (setq glyph (car glyph-list)))
  304.           (setq width (+ width bevel (glyph-width glyph)))
  305.           (or height (setq height (+ bevel (glyph-height glyph))))))
  306.       (setq toolbar (cdr toolbar)))
  307.     (set-specifier top-toolbar-height height floating-toolbar-frame)
  308.     (set-frame-width floating-toolbar-frame
  309.              (1+ (/ width (font-width (face-font 'default)
  310.                       floating-toolbar-frame))))))
  311.  
  312. (defun floating-toolbar-set-toolbar-frame-position (x y)
  313.   (set-frame-position floating-toolbar-frame x y))
  314.  
  315. (defun floating-toolbar-make-junk-frame ()
  316.   (let ((window-min-height 1)
  317.     (window-min-width 1))
  318.     (save-excursion
  319.       (set-buffer (generate-new-buffer "*junk-frame-buffer*"))
  320.       (prog1
  321.       (make-frame '(minibuffer t initially-unmapped t width 1 height 1))
  322.     (rename-buffer " *junk-frame-buffer*" t)))))
  323.  
  324. (defun floating-toolbar-make-toolbar-frame (x y)
  325.   (save-excursion
  326.     (let ((window-min-height 1)
  327.       (window-min-width 1)
  328.       (bg-color (or (x-get-resource "backgroundToolBarColor"
  329.                     "BackgroundToolBarColor"
  330.                     'string
  331.                     'global
  332.                     (selected-device)
  333.                     t)
  334.             "grey75"))
  335.       (buffer (get-buffer-create " *floating-toolbar-buffer*"))
  336.       (frame nil))
  337.       (set-buffer buffer)
  338.       (set-buffer-menubar nil)
  339.       (if floating-toolbar-help-font
  340.       (progn (set-buffer (window-buffer (minibuffer-window)))
  341.          (set-buffer-menubar nil)))
  342.       (setq frame (make-frame (list
  343.                    '(initially-unmapped . t)
  344.                    ;; try to evade frame decorations
  345.                    (cons 'name (or floating-toolbar-frame-name
  346.                            "xclock"))
  347.                    '(border-width . 2)
  348.                    (cons 'border-color bg-color)
  349.                    (cons 'top y)
  350.                    (cons 'left x)
  351.                    (cons 'popup
  352.                      (floating-toolbar-make-junk-frame))
  353.                    (if floating-toolbar-help-font
  354.                    '(minibuffer . only)
  355.                  '(minibuffer . nil))
  356.                    '(width . 3)
  357.                    '(height . 1))))
  358.       (set-specifier text-cursor-visible-p (cons frame nil))
  359.       (if floating-toolbar-help-font
  360.       (set-face-font 'default floating-toolbar-help-font frame)
  361.     (set-face-font 'default "nil2" frame))
  362.       (set-face-background 'default bg-color frame)
  363.       (set-face-background 'modeline bg-color frame)
  364.       (set-specifier modeline-shadow-thickness (cons frame 1))
  365.       (set-specifier has-modeline-p (cons frame nil))
  366.       (set-face-background-pixmap 'default "" frame)
  367.       (set-window-buffer (frame-selected-window frame) buffer)
  368.       (set-specifier top-toolbar-height (cons frame 0))
  369.       (set-specifier left-toolbar-width (cons frame 0))
  370.       (set-specifier right-toolbar-width (cons frame 0))
  371.       (set-specifier bottom-toolbar-height (cons frame 0))
  372.       (set-specifier top-toolbar (cons frame nil))
  373.       (set-specifier left-toolbar (cons frame nil))
  374.       (set-specifier right-toolbar (cons frame nil))
  375.       (set-specifier bottom-toolbar (cons frame nil))
  376.       (set-specifier scrollbar-width (cons frame 0))
  377.       (set-specifier scrollbar-height (cons frame 0))
  378.       frame )))
  379.  
  380. ;; first popup should be faster if we go ahead and make the frame now.
  381. (or (not (featurep 'toolbar))
  382.     floating-toolbar-frame
  383.     (not (eq (device-type) 'x))
  384.     (setq floating-toolbar-frame (floating-toolbar-make-toolbar-frame 0 0)))
  385.  
  386. ;;; floating-toolbar.el ends here
  387.